home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Digital Co236857282001.psc / UserControl1.ctl < prev   
Encoding:
Visual Basic user-defined control file  |  2000-09-09  |  9.8 KB  |  449 lines
  1. VERSION 5.00
  2. Object = "{27395F88-0C0C-101B-A3C9-08002B2F49FB}#1.1#0"; "PICCLP32.OCX"
  3. Begin VB.UserControl Marquee 
  4.    BackColor       =   &H80000008&
  5.    ClientHeight    =   450
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   3405
  9.    ScaleHeight     =   450
  10.    ScaleWidth      =   3405
  11.    ToolboxBitmap   =   "UserControl1.ctx":0000
  12.    Begin VB.Timer Timer1 
  13.       Enabled         =   0   'False
  14.       Left            =   0
  15.       Top             =   0
  16.    End
  17.    Begin PicClip.PictureClip PicClip1 
  18.       Left            =   360
  19.       Top             =   720
  20.       _ExtentX        =   52599
  21.       _ExtentY        =   820
  22.       _Version        =   393216
  23.       Cols            =   70
  24.       Picture         =   "UserControl1.ctx":0312
  25.    End
  26.    Begin PicClip.PictureClip PicClip2 
  27.       Left            =   360
  28.       Top             =   1200
  29.       _ExtentX        =   52599
  30.       _ExtentY        =   820
  31.       _Version        =   393216
  32.       Cols            =   70
  33.       Picture         =   "UserControl1.ctx":F820
  34.    End
  35.    Begin PicClip.PictureClip PicClip3 
  36.       Left            =   360
  37.       Top             =   1680
  38.       _ExtentX        =   52599
  39.       _ExtentY        =   820
  40.       _Version        =   393216
  41.       Cols            =   70
  42.       Picture         =   "UserControl1.ctx":1ED2E
  43.    End
  44.    Begin PicClip.PictureClip PicClip4 
  45.       Left            =   360
  46.       Top             =   2160
  47.       _ExtentX        =   52599
  48.       _ExtentY        =   820
  49.       _Version        =   393216
  50.       Cols            =   70
  51.       Picture         =   "UserControl1.ctx":2E23C
  52.    End
  53.    Begin VB.Image Image1 
  54.       Height          =   375
  55.       Index           =   0
  56.       Left            =   0
  57.       Top             =   120
  58.       Visible         =   0   'False
  59.       Width           =   255
  60.    End
  61. End
  62. Attribute VB_Name = "Marquee"
  63. Attribute VB_GlobalNameSpace = False
  64. Attribute VB_Creatable = True
  65. Attribute VB_PredeclaredId = False
  66. Attribute VB_Exposed = True
  67. Option Explicit
  68. Private Const YellowDigit = 4
  69. Private Const RedDigit = 3
  70. Private Const GreenDigit = 2
  71. Private Const BlueDigit = 1
  72. Private Const sCaption = "PANOS MARQUEE"
  73. Private Const DEF_Interval = 1000
  74. Dim i, Chars As Integer, DEF_Width, dig As Integer, Cptn As String
  75. Dim Intrvl As Integer, Looped As Boolean, temp As String
  76. Dim s, k, d
  77. Enum DColors
  78. BlueDigits = 1
  79. GreenDigits = 2
  80. RedDigits = 3
  81. YellowDigits = 4
  82. End Enum
  83. Private Sub Timer1_Timer()
  84. If Looped Then
  85. d = d + 1
  86. If d > Len(temp) Then d = 1
  87. k = Mid(temp, d, Chars)
  88. For i = 1 To Chars
  89. s = Mid(k, i, 1)
  90.         Select Case dig
  91.         Case 1
  92.         Image1(i).Picture = PicClip1.GraphicCell(GetLetter(s))
  93.         Case 2
  94.         Image1(i).Picture = PicClip2.GraphicCell(GetLetter(s))
  95.         Case 3
  96.         Image1(i).Picture = PicClip3.GraphicCell(GetLetter(s))
  97.         Case 4
  98.         Image1(i).Picture = PicClip4.GraphicCell(GetLetter(s))
  99.         End Select
  100. Next
  101. Else
  102. d = d + 1
  103. If d >= Len(temp) Then d = 1
  104. k = Mid(temp, Len(temp) - d, Chars)
  105. For i = 1 To Chars
  106. s = Mid(k, i, 1)
  107.         Select Case dig
  108.         Case 1
  109.         Image1(i).Picture = PicClip1.GraphicCell(GetLetter(s))
  110.         Case 2
  111.         Image1(i).Picture = PicClip2.GraphicCell(GetLetter(s))
  112.         Case 3
  113.         Image1(i).Picture = PicClip3.GraphicCell(GetLetter(s))
  114.         Case 4
  115.         Image1(i).Picture = PicClip4.GraphicCell(GetLetter(s))
  116.         End Select
  117.  
  118. Next
  119.  
  120. End If
  121.  
  122. End Sub
  123.  
  124. Private Sub UserControl_Initialize()
  125. Image1(0).Picture = PicClip1.GraphicCell(0)
  126. Image1(0).Top = 0
  127. DEF_Width = Image1(0).Width
  128. Image1(0).Left = 0 - Image1(0).Width
  129. UserControl.Height = Image1(0).Height
  130. UserControl.Width = 0
  131. Chars = 0
  132. dig = 1
  133. ShowDigits
  134. Digitcolor = BlueDigit
  135. Caption = sCaption
  136. Interval = DEF_Interval
  137. LoopFromLeft = True
  138. UserControl.Width = DEF_Width * Chars
  139. End Sub
  140.  
  141. Private Sub UserControl_Resize()
  142. Dim New_Width
  143. On Error Resume Next
  144. If UserControl.Height <> Image1(0).Height Then UserControl.Height = Image1(0).Height
  145. If UserControl.Width > DEF_Width * Chars Then
  146.     New_Width = (UserControl.Width - (DEF_Width * Chars)) \ DEF_Width
  147.     If New_Width = 0 Then New_Width = 1
  148.     For i = Chars + 1 To Chars + New_Width
  149.         Load Image1(i)
  150.         Image1(i).Left = Image1(i - 1).Left + Image1(i - 1).Width
  151.         Select Case dig
  152.         Case 1
  153.         Image1(i).Picture = PicClip1.GraphicCell(46)
  154.         Case 2
  155.         Image1(i).Picture = PicClip2.GraphicCell(46)
  156.         Case 3
  157.         Image1(i).Picture = PicClip3.GraphicCell(46)
  158.         Case 4
  159.         Image1(i).Picture = PicClip4.GraphicCell(46)
  160.         End Select
  161.         Image1(i).Visible = True
  162.     Next
  163.     Chars = Chars + New_Width
  164.     UserControl.Width = DEF_Width * Chars
  165. ElseIf UserControl.Width < DEF_Width * Chars Then
  166.     New_Width = ((DEF_Width * Chars) - UserControl.Width) \ DEF_Width
  167.     If New_Width = 0 Then
  168.         Unload Image1(Chars)
  169.         Chars = Chars - 1
  170.         UserControl.Width = DEF_Width * Chars
  171.     Else
  172.         RemoveChars (Chars - New_Width)
  173.         Chars = Chars - New_Width
  174.         UserControl.Width = DEF_Width * Chars
  175.     End If
  176. End If
  177.  
  178. Exit Sub
  179.  
  180. panos:
  181. Exit Sub
  182. End Sub
  183.  
  184. Private Sub RemoveChars(sChars As Integer)
  185. For i = Chars To sChars Step -1
  186. Unload Image1(i)
  187. Next
  188. End Sub
  189.  
  190.  
  191. Private Function GetLetter(ByVal ooo As String) As Integer
  192. Select Case ooo
  193. Case "0"
  194. GetLetter = 0
  195. Case "1"
  196. GetLetter = 1
  197. Case "2"
  198. GetLetter = 2
  199. Case "3"
  200. GetLetter = 3
  201. Case "4"
  202. GetLetter = 4
  203. Case "5"
  204. GetLetter = 5
  205. Case "6"
  206. GetLetter = 6
  207. Case "7"
  208. GetLetter = 7
  209. Case "8"
  210. GetLetter = 8
  211. Case "9"
  212. GetLetter = 9
  213. Case "A"
  214. GetLetter = 10
  215. Case "┴"
  216. GetLetter = 10
  217. Case "B"
  218. GetLetter = 11
  219. Case "┬"
  220. GetLetter = 11
  221. Case "C"
  222. GetLetter = 12
  223. Case "D"
  224. GetLetter = 13
  225. Case "E"
  226. GetLetter = 14
  227. Case "┼"
  228. GetLetter = 14
  229. Case "F"
  230. GetLetter = 15
  231. Case "G"
  232. GetLetter = 16
  233. Case "H"
  234. GetLetter = 17
  235. Case "╟"
  236. GetLetter = 17
  237. Case "I"
  238. GetLetter = 18
  239. Case "╔"
  240. GetLetter = 18
  241. Case "J"
  242. GetLetter = 19
  243. Case "K"
  244. GetLetter = 20
  245. Case "╩"
  246. GetLetter = 20
  247. Case "L"
  248. GetLetter = 21
  249. Case "M"
  250. GetLetter = 22
  251. Case "╠"
  252. GetLetter = 22
  253. Case "N"
  254. GetLetter = 23
  255. Case "═"
  256. GetLetter = 23
  257. Case "O"
  258. GetLetter = 24
  259. Case "╧"
  260. GetLetter = 24
  261. Case "P"
  262. GetLetter = 25
  263. Case "╤"
  264. GetLetter = 25
  265. Case "Q"
  266. GetLetter = 26
  267. Case "R"
  268. GetLetter = 27
  269. Case "S"
  270. GetLetter = 28
  271. Case "T"
  272. GetLetter = 29
  273. Case "╘"
  274. GetLetter = 29
  275. Case "U"
  276. GetLetter = 30
  277. Case "V"
  278. GetLetter = 45
  279. Case "W"
  280. GetLetter = 31
  281. Case "X"
  282. GetLetter = 32
  283. Case "╫"
  284. GetLetter = 32
  285. Case "Y"
  286. GetLetter = 33
  287. Case "╒"
  288. GetLetter = 33
  289. Case "Z"
  290. GetLetter = 34
  291. Case "╞"
  292. GetLetter = 34
  293. Case "├"
  294. GetLetter = 35
  295. Case "─"
  296. GetLetter = 36
  297. Case "╚"
  298. GetLetter = 37
  299. Case "╦"
  300. GetLetter = 38
  301. Case "╬"
  302. GetLetter = 39
  303. Case "╨"
  304. GetLetter = 40
  305. Case "╙"
  306. GetLetter = 41
  307. Case "╓"
  308. GetLetter = 42
  309. Case "╪"
  310. GetLetter = 43
  311. Case "┘"
  312. GetLetter = 44
  313. Case " "
  314. GetLetter = 46
  315. Case "."
  316. GetLetter = 47
  317. Case ","
  318. GetLetter = 48
  319. Case ":"
  320. GetLetter = 49
  321. Case ";"
  322. GetLetter = 50
  323. Case "+"
  324. GetLetter = 51
  325. Case "-"
  326. GetLetter = 52
  327. Case "="
  328. GetLetter = 53
  329. Case "$"
  330. GetLetter = 54
  331. Case "!"
  332. GetLetter = 55
  333. Case "#"
  334. GetLetter = 56
  335. Case "&"
  336. GetLetter = 57
  337. Case "("
  338. GetLetter = 58
  339. Case ")"
  340. GetLetter = 59
  341. Case "?"
  342. GetLetter = 60
  343. Case "*"
  344. GetLetter = 61
  345. Case "/"
  346. GetLetter = 62
  347. Case "%"
  348. GetLetter = 63
  349. Case "<"
  350. GetLetter = 64
  351. Case ">"
  352. GetLetter = 65
  353. Case "["
  354. GetLetter = 66
  355. Case "]"
  356. GetLetter = 67
  357. Case "{"
  358. GetLetter = 68
  359. Case "}"
  360. GetLetter = 69
  361. Case Else
  362. GetLetter = 46
  363. End Select
  364. End Function
  365.  
  366. Public Property Get Digitcolor() As DColors
  367. Attribute Digitcolor.VB_Description = "Sets the Digit Color possible values 1 - 4"
  368. If dig > 4 Then dig = 1
  369. Digitcolor = dig
  370. End Property
  371. Public Property Let Digitcolor(sColor As DColors)
  372.     dig = sColor
  373.     If dig > 4 Or dig < 1 Then
  374.     dig = 1
  375.     MsgBox "Use 1 for Blue Digits, 2 for Green Digits, 3 for Red Digits or 4 for Yellow Digits", vbExclamation, App.Title
  376.     End If
  377.     'DeleteDigits
  378.     RefDigits
  379.     PropertyChanged "DigitColor"
  380.  
  381. End Property
  382.  
  383. Private Sub ShowDigits()
  384. For i = 1 To 10
  385. Chars = Chars + 1
  386. Load Image1(i)
  387. Image1(i).Left = Image1(i - 1).Left + Image1(i - 1).Width
  388. Select Case dig
  389. Case 1
  390. Image1(i).Picture = PicClip1.GraphicCell(46)
  391. Case 2
  392. Image1(i).Picture = PicClip2.GraphicCell(46)
  393. Case 3
  394. Image1(i).Picture = PicClip3.GraphicCell(46)
  395. Case 4
  396. Image1(i).Picture = PicClip4.GraphicCell(46)
  397. End Select
  398. Image1(i).Visible = True
  399. Next
  400.  
  401. End Sub
  402.  
  403. Private Sub DeleteDigits()
  404. For i = Chars To 1 Step -1
  405. Unload Image1(i)
  406. Next
  407. Chars = 0
  408. End Sub
  409.  
  410. Private Sub RefDigits()
  411. For i = 1 To Chars
  412. Select Case dig
  413. Case 1
  414. Image1(i).Picture = PicClip1.GraphicCell(46)
  415. Case 2
  416. Image1(i).Picture = PicClip2.GraphicCell(46)
  417. Case 3
  418. Image1(i).Picture = PicClip3.GraphicCell(46)
  419. Case 4
  420. Image1(i).Picture = PicClip4.GraphicCell(46)
  421. End Select
  422. Next
  423.  
  424. End Sub
  425.  
  426. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  427.     On Error GoTo ReadPropErr
  428.     Digitcolor = PropBag.ReadProperty("DigitColor", YellowDigit)
  429.     Caption = PropBag.ReadProperty("Caption", sCaption)
  430.     Interval = PropBag.ReadProperty("Interval", 1000)
  431.     LoopFromLeft = PropBag.ReadProperty("LoopFromLeft", True)
  432. EndReadProp:
  433.     Exit Sub
  434. ReadPropErr:
  435.     'Use default property settings
  436.     Resume EndReadProp
  437. End Sub
  438.  
  439.  
  440. 'Save control properties
  441. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  442.     PropBag.WriteProperty "DigitColor", Digitcolor, YellowDigit
  443.     PropBag.WriteProperty "Caption", Caption, sCaption
  444.     PropBag.WriteProperty "Interval", Interval, DEF_Interval
  445.     PropBag.WriteProperty "LoopFromLeft", LoopFromLeft, True
  446. End Sub
  447.  
  448. Public Property Get Caption() As String
  449. Attribute Caption.VB_Description = "Sets the message to be displayed supporiXCtrn= DEF_5(pelitePy
  450. omLeft